{- 

    Copyright © 2011 - 2021, Ingo Wechsung
    All rights reserved.

    Redistribution and use in source and binary forms, with or
    without modification, are permitted provided that the following
    conditions are met:

        Redistributions of source code must retain the above copyright
        notice, this list of conditions and the following disclaimer.

        Redistributions in binary form must reproduce the above
        copyright notice, this list of conditions and the following
        disclaimer in the documentation and/or other materials provided
        with the distribution. Neither the name of the copyright holder
        nor the names of its contributors may be used to endorse or
        promote products derived from this software without specific
        prior written permission.

    THIS SOFTWARE IS PROVIDED BY THE
    COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR
    IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
    WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
    PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER
    OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
    SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
    LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
    USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
    AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING
    IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF
    THE POSSIBILITY OF SUCH DAMAGE.

     -}

{--
 * This package implements the second compiler pass after lexical analysis.
 * It sets up the symbol table and performs the imports.
 -}

package frege.compiler.passes.Imp where

import frege.Prelude hiding (<+>)

import Data.TreeMap as TM(TreeMap, keys, insert, insertWith, each, values, lookup)
import Data.List as DL(sortBy, zipWith4)
import Data.Bits(BitSet.BitSet)

import  Compiler.enums.Flags
import  Compiler.enums.TokenID(CONID, VARID, defaultInfix, ROP4)
import  Compiler.enums.Visibility
import  Compiler.enums.SymState

import  Compiler.types.Positions
import  Compiler.types.Tokens
import  Compiler.types.Strictness
import  Compiler.types.NSNames
import  Compiler.types.SNames
import  Compiler.types.Packs
import  Compiler.types.ImportDetails
import  Compiler.types.QNames
import  Compiler.types.Types
import  Compiler.types.Targets
-- import  Compiler.types.Definitions(Expr)
import  Compiler.types.SourceDefinitions
import  Compiler.types.ConstructorField
import  Compiler.types.Symbols
import  Compiler.types.Global as G

import  Compiler.common.Errors as E()
import  Compiler.common.Resolve as R(docWarning, resolve)
import  Compiler.common.SymbolTable
import  Compiler.common.ImpExp

import  Compiler.classes.Nice

import frege.compiler.Classtools    as CT()
import frege.compiler.Utilities     as U()

import Lib.PP(msgdoc, text, <+>, <>, </>)



--- import pass, set up environment and do imports
pass :: StIO (String, Int)
pass = do
            g <- getSTT
            initenv g.thisPack
            g <- getSTT
            -- changeSTT Global.{sub <- _.{localSV = g.locals}}
            return ("packages", length (keys g.packages))
    where
        initenv p
            | p == pPreludeBase = do
                                     mkSymtabs
                                     g <- getSTT
                                     -- add alias "PreludeBase" for namespace
                                     changeSTT Global.{namespaces <- insert (NSX "PreludeBase") g.thisPack}
                                     liftStG preludeBasics
            | otherwise         = do mkSymtabs; doImports
            where
                -- make sure we find our own symtab
                mkSymtabs = do
                    g <- getSTT
                    let
                        newn = TM.singleton g.thisPack.nsName g.thisPack
                    changeSTT Global.{namespaces = newn}
                    -- in iDE mode, we may have previously imported packages
                    -- we want to keep, otherwise it is empty anyways
                    changeSTT Global.{packages <- insert g.thisPack empty}
                    -- honour the invariant that funPointers and packages must have the same keys.
                    -- changeSTT Global.{sub <- _.{funPointers <- insert g.thisPack []}}



--- The list of imports that must always be performed, constructed from 'preludePacks'
importAlways = [ ImpDcl {pos=Position.null, pack=Pack.raw p, as=Just n, imports = linkNone} |
                    (p, Just n) <- preludePacks ]



--- Go through the definitions and find out what needs to be imported.
--- Add an
--- > import frege.Prelude
--- unless there is an explicit import already or this is a prelude package.
importsFor :: Global -> [DefinitionS]
importsFor g = if noPreludeNeeded 
                then imports 
                else fakePreludeImport : imports
    where
        -- frege.Prelude needs not get added if one of the following holds:
        -- • This is a prelude package
        -- • There is an explicit frege.Prelude import
        noPreludeNeeded = 
                isOn g.options.flags INPRELUDE                      
                || any ((pPrelude==) . Pack.new . _.pack) imports   
        imports = if isOff g.options.flags INPRELUDE
                    then importAlways ++ importDefs
                    else importDefs
        importDefs = [ imp | imp@ImpDcl{} <- g.sub.sourcedefs ]
        -- import frege.Prelude
        fakePreludeImport  = ImpDcl {pos=Position.null, 
                                pack=Pack.raw pPrelude, 
                                as=Just "Prelude", imports = linkAll}  

--- Find the packages this one depends upon.
dependsOn ∷ Global → [Pack]
dependsOn g = [ Pack.new pack | ImpDcl{pack} <- importsFor g ]

--- Find the java classes mentioned in the definitions
dependsOnNative ∷ Global → [Pack]
dependsOnNative g = [ Pack.new jclas | JavDcl{name, isPure, jclas} ← g.definitions, 
            jclas `notElem` G.primitiveTypes,
            jclas `notElem` keys G.shortClassName,
            not (jclas.startsWith "java."),             -- avoid JDK classes
            not (jclas.startsWith "frege.runtime."),    -- avoid frege runtime classes
        ]                

{--
 * check definitions for Prelude import.
 * if not there, prepend an automatic @import frege.Prelude@
 -}
doImports = do
    g <- getSTT
    let imports = importsFor g
    forsome imports importHere

        -- now that we have resolved all imported names, we can build
    -- up the nsUsed map
    changeSTT _.{sub <- _.{nsUsed = empty}}     -- start out with empty ns use
    forsome imports useIfPublic


{--
    If there are any re-exports from an import,
    mark the namespace as used, so as to avoid
    "unused import" messages.
-}
useIfPublic :: DefinitionS -> StIO ()
useIfPublic (imp@ImpDcl {pos,imports}) = do
    g <- getSTT
    let pack = Pack.new imp.pack
        as   = maybe pack.nsName NSX imp.as
    when (imports.publik || any _.publik imports.items) do
        changeSTT _.{sub <- _.{nsUsed <- insert as ()}}    
useIfPublic _ = return ()

importHere :: DefinitionS -> StIO ()
importHere (imp@ImpDcl {pos,imports}) = do
        g <- getSTT
        let pack = Pack.new imp.pack
            as   = maybe pack.nsName NSX imp.as
            exists = g.namespaces.lookup as
        liftStG do
            changeST Global.{sub <- SubSt.{nsPos <- insert as imp.pos}}
            changeST _.{sub <- _.{packWhy <- insert pack [as]}}
        maybe (newns imp pack as) (liftStG . oldns imp pack as) exists
    where
        newns imp pack as = do
                importClass pos as pack        -- make sure g.packages pack exists when no error
                g <- getSTT
                case g.packages.lookup pack of
                    Just env -> do
                        changeSTT Global.{namespaces <- insert as pack}
                        --mbfp <- getFP (g.unpack pack)
                        --case mbfp of
                        --    Right (Just fp) -> liftStG do
                        --            docWarning pos ("module " ++ g.unpack pack)
                        --                            (Just fp.doc) 
                        --    nothing  -> return ()
                        liftStG (importEnvSilent pos env as pack imports)
                    Nothing -> return ()      -- importClass did the error logging
        oldns imp pack as oldp = do
                g <- getST
                let old = g.unpack oldp
                when (pack != oldp) do
                    E.error pos (msgdoc ("namespace `"
                                        ++ NSName.unNS as ++ "` previously opened for `"
                                        ++ old ++ "`"))
                when (pack == oldp) do
                    -- g <- getST

                    case g.packages.lookup pack of
                        Just env -> importEnvSilent pos env as pack imports
                        Nothing -> E.fatal pos (text ("module " ++ g.unpack pack ++ " should be here?"))
                stio ()
importHere d = liftStG $ E.fatal d.pos (text ("must be an import definition, not " ++ show (constructor d)))


--- Avoid warnings when we resolve items in the imported package
importEnvSilent pos env ns pack imps = do
    changeST Global.{options <- Options.{flags <- flagSet NODOCWARNINGS}}
    importEnv pos env ns pack imps
    changeST Global.{options <- Options.{flags <- flagClr NODOCWARNINGS}}
     
{--
    Process an import list

    An export list with except list is equivalent to one that names all public
    top level symbols whose name does not appear in the list.
-}
importEnv :: Position -> Symtab -> NSName -> Pack -> ImportList -> StG ()
importEnv pos env ns pack (imp@Imports {except=true, items}) = do
        g <- getST
        let xs = [ withNS ns.unNS  (ImportItem.name e) | e <- items ]
        exss <- mapSt (resolve (VName g.thisPack) pos) xs
        let exs = fold (++) [] exss
            nitems = [ protoItem.{ name = Simple pos.first.{tokid=VARID, value=(Symbol.name sym).base},
                                      members = nomem csym,
                                      alias   = (Symbol.name sym).base} |
                        sym <- sortBy (comparing constructor) (values env),         -- place SymL before SymC
                        csym <- (g.findit sym.name),
                        not (Symbol.{cid?} csym)                                    -- no constructors
                            || (Symbol.name sym).base != (Symbol.name csym).base,   -- except renamed ones
                        Symbol.name csym `notElem` exs,
                        Symbol.vis sym == Public
                     ]
            nomem (SymC {}) = Just []
            -- nomem (SymT {}) = Just []
            nomem _         = Nothing
        importEnv pos env ns pack imp.{except=false, items=nitems}

--- A public import list is equivalent to one without public but public specified for all items.
importEnv pos env ns pack (imp@Imports {publik=true, items})
    = importEnv pos env ns pack imp.{publik = false, items <- map ImportItem.export}
--- All items in the list are processed one by one
importEnv pos env ns pack (Imports {items}) = foreach items (linkItem ns.unNS pack)

--- a symbolic link is dereferenced and the link goes to the target
linkHere ns pack (item@Item {alias=itema}) (link@SymL {name, alias}) = do
    let pos = Pos item.name.id item.name.id
    g <- getST
    case g.findit alias of
        Just sym -> linkHere ns pack item sym
        Nothing -> E.fatal (pos) (text (link.name.nice g ++ " points to non-existing " ++ link.alias.nice g))

-- an alias of Nothing is replaced by the base name of the item linked to
-- linkHere ns pack (item@Item {alias=Nothing}) sym = linkHere ns pack item.{alias = Just sym.name.base} sym

-- linkHere ns pack (item@Item {alias=Just ""}) sym = E.fatal item.pos ("bad alias for " ++ item.name ++ ", must be at least 1 char")

-- otherwise the alias is checked for correctness
linkHere ns pack (item@Item {publik,name,members,alias=newn}) sym = do
    let pos   = Pos name.id name.id
    let conid = (newn.charAt 0).isUpperCase
        conidOk
            | TName _ _ <- sym.name = true
            | SymD {}   <- sym      = true
            | otherwise             = false
        vis = if publik then Public else Private
    g <- getST
    E.logmsg TRACE2 pos (text ("linkHere: " ++ ns ++ "." ++ newn ++ ", vis =" ++ show vis
        ++ " ==> " ++  nice sym g))
    changeST Global.{sub <- SubSt.{
        idKind <- insert (KeyTk pos.first) (Right sym.name)}}

    let !errors = case sym.name of
          TName _ b
            | newn == sym.name.base || conid = linkqvp (TName g.thisPack newn) sym vis pos
            | otherwise = do
                E.error pos (msgdoc ("Alias for " ++ nice sym g ++ " must be a type name, not `" ++ newn ++ "'"))
                stio ()
          _
            | newn == sym.name.base || conid == conidOk = linkqvp (VName g.thisPack newn) sym vis pos
            -- allow variables that link to constructors
            | SymD{} <- sym, !conid = linkqvp (VName g.thisPack newn) sym vis pos 
            | otherwise = do
                E.error pos (msgdoc ("Alias for " ++ nice sym g ++ " must be a "
                    ++ (if conidOk then "constructor" else "variable")
                    ++ " name, not  `" ++ newn ++ "'"))
                stio ()

    -- tell why we imported this 'item'
    -- if the 'item' belongs to a different packages from 'pack', it means it is a re-exported item.
    -- in that case, append 'ns' to note through which import definition introduced the 'item'
    let noteWhy (TName {pack=p}) = noteReExported p
        noteWhy (VName {pack=p}) = noteReExported p
        noteWhy (MName {tynm})   = noteWhy tynm
        noteWhy (Local{})        = stio ()
        noteReExported p | p /= pack = changeST _.{sub <- _.{packWhy <- insertWith (++) p [NSX ns]}}
                         | otherwise = changeST _.{sub <- _.{packWhy <- insert p [NSX ns]}}
    noteWhy sym.name

    errors 
    case sym of
        SymT {env}
            | Nothing <- members = do        -- link constructors also
                let cons = [ item.{name <- (pos.first.{tokid=CONID, value=mem.name.base} `qBy`),
                                    members = Nothing,
                                    alias = mem.name.base, publik = false}
                                | mem@SymD {} <- values env, mem.vis == Public ]
                foreach cons (linkItem ns pack)
            | Just ms <- members = do
                let nms = map  ImportItem.{name <- (`qBy` item.name) • SName.id} ms
                foreach nms (linkItem ns pack)
        SymC {env}
            | Nothing <- members =  do        -- link class methods
                let meth = [  item.{name <- (pos.first.{tokid=VARID, value=sym.name.base} `qBy`),
                                    members = Nothing, alias = sym.name.base}
                                | sym@SymV {vis} <- values env,
                                  vis == Public || vis == Abstract,
                                  not (defined sym.name.base) ]     -- import only yet undefined class members
                    -- here = g.thisTab
                    defined s = isJust (g.find (VName g.thisPack s))
                foreach meth (linkItem ns pack)
            | Just ms <- members = do
                let nms = map  ImportItem.{name <- (`qBy` item.name) • SName.id} ms
                foreach nms (linkItem ns pack)
        _ -> if isNothing members then stio ()
             else do
                E.error pos (msgdoc ("Member list not allowed for " ++ show name))
                stio ()

linkItem ns pack (item@Item {publik,name,members,alias}) = do
    g <- getST
    let pos = Pos name.id name.id
    res <- resolve (VName g.thisPack) pos (withNS ns name)
    case mapMaybe g.findit res of
        [] -> stio ()       -- got error message from resolve or excluded
        [sym] -> linkHere ns pack item sym
        syms                -- look for a type name
            | (tsym:_) <- [ x | x <- syms, TName{} <- Just x.name] 
            = linkHere ns pack item tsym
            | otherwise = do        -- by taking the first result, we resolve NS.x
                linkHere ns pack item (head syms)



importClass :: Position -> NSName -> Pack -> StIO ()
importClass pos why pack = do
    g <- getSTT
    case g.packages.lookup pack of
        Just{} -> return ()         -- is already here
        _  |  isOn g.options.flags TRACE2, 
              traceLn ("import: need to import " ++ g.unpack pack) = undefined
           | otherwise  -> do
                importClassData pos why pack
                return ()

{-- 
    Get the frege package that is named in the argument
    through the global loader.
    -}
getFP :: String -> StIO (ClassNotFoundException | Maybe CT.FregePackage)
getFP !clname = do
    g <- getSTT
    liftIO (CT.getFrege g.sub.loader clname >>= return . Right 
                            `catch` notfound)

notfound :: ClassNotFoundException -> IO (ClassNotFoundException | Maybe CT.FregePackage)
notfound = return . Left


{--
 * Reconstruct symbol table of imported package from annotation class 'CT.FregePackage'
 *
 * Only the most obvious logical errors are recognized, however, they will cause the
 * compiler to crash.
 *
 * We rely on the following:
 * - java annotations contain no null values
 * - all indexes into the 'CT.Tau', 'CT.Rho' and 'CT.Sigma' arrays are valid.
 *
 * Should the assumptions fail to hold then the import will crash with an ArrayOutOfBounds
 * or a NullPointer exception.
 *
 * On the other hand, if the code in "GenMeta.fr" is correct and the annotations have
 * not been hacked (for example by editing intermediate java files), then the import is
 * guaranteed not to crash.
 *
 * This uses and updates the cache of frege packages from class files which are up to date
 * whether or not the 'MAKE' option is set. This avoids construction of a class loader
 * also in cases when multiple source files are compiled.
 -}
importClassData :: Position -> NSName -> Pack -> StIO (Maybe CT.FregePackage)
importClassData pos why pack = do
    g <- getSTT
    let clname = g.unpack pack
    liftStG $ E.logmsg TRACE2 pos (text ("importing " ++ clname))
    let mkpos off nm = Pos t t where
            t :: Token
            t = pos.first.{tokid=VARID, value=nm, offset=off, qual= []}
        -- getFrege (Left x) clname   = IO.return (Left x)
        -- getFrege (Right cl) clname = CT.getFrege cl clname
    anno <- getFP clname
    case anno of
        Left exc
            | inPrelude g.thisPack g, inPrelude pack g = do
                -- a prelude package may miss a name space, but must then not use
                -- the syntactic sugar that is provided through it
                return Nothing
            | otherwise = do
                liftStG $ E.error pos (msgdoc ("Could not import module "
                                            ++ clname
                                            ++ " (" ++ exc.show ++ ")"))
                return Nothing
        Right Nothing -> do
            liftStG $ E.error pos (msgdoc ("`" ++ clname ++ "` is not a frege module"))
            return Nothing
        Right (Just fp)
            | that <- Target  fp.jmajor fp.jminor,
              usedTarget <- g.options.target,
              (usedTarget <= java7) != (that <= java7) = do
                liftStG $ E.error pos (text "cannot import" <+> text clname 
                    </> (text "compiled for target " <+> text (show that) 
                        <+> text (if that <= java7 
                                        then "(without lambda support)" 
                                        else "(with lambda support)")
                        )
                    </> (text "when the current target " <+> text (show usedTarget)
                        <+> text (if usedTarget <= java7
                                    then "hasn't lambda support."
                                    else "has lambda support"))
                    </> (if thisTarget >= that
                            then text "Try to use compiler option -target"
                                    <+> text (show that)
                            else text "You cannot use JDK" <+> text (show thisTarget)
                                    <+> text "with libraries compiled for" <+> text (show that))
                    )
                return Nothing 
        Right (Just fp) -> do
            g <- getSTT
            let packs = [ Pack.new p | 
                            p <- listFromArray fp.imps ]
            forM_ packs (importClass pos why)
            -- now everything is in place for making the new symtab
            changeSTT Global.{packages <- insert pack empty}
            -- importFunctionPointers pack
            let -- itree = fold rebuildTau Tree.empty (enumFromTo 0 (fp.taus.length-1))
                -- Relies on the property that there may be no forward references.
                -- The function that builds it must guarantee this. see GenMeta.tauIndex
                karray = arrayCache mkTau fp.taus.length
                    where mkTau n t = ctTau fp.taus.[n]

                -- Tau
                tarray = arrayCache rebuildTau fp.taus.length
                rebuildTau n t = tauFromA karray (karray.[n]) t
                nTau i = elemAt tarray i

                -- Kinds
                -- karray = arrayCache rebuildKind fp.kinds.length
                rebuildKind n  = kindFromA (karray.[n]) karray tarray 
                nKind i = rebuildKind i

                -- Rhos
                saarr  = genericArrayMap ctSigma fp.sigmas
                rarray = arrayCache rebuildRho fp.rhos.length
                rebuildRho n arr = rhoFromA karray tarray saarr (ctRho fp.rhos.[n]) arr
                -- nRho i = elemAt rarray i


                -- Sigmas
                sarray = genericArrayMap (sigmaFromA karray tarray rarray) saarr    
                nSigma i = sarray.[i]

                -- Exprs
                eaarr = genericArrayMap ctExpr fp.exprs
                rbExpr :: Int -> Maybe (ExprD Global)
                rbExpr 0 = Nothing
                rbExpr ix = Just (exprFromA sarray eaarr eaarr.[ix])

                
            let strMB "" = Nothing
                strMB s  = Just s
            let rbSymA n = SymA {sid=0, pos=mkpos sym.offset sym.name.base, vis, 
                    doc  = strMB sym.doc,
                    name = rebuildQN sym.name,
                    typ = nSigma sym.typ,
                    kind = nKind sym.kind,
                    vars = [ nTau varn | varn <- listFromArray sym.vars]}
                  where sym = elemAt fp.symas n
                        vis = if sym.publik then Public else Protected
                rbSymV :: CT.SymVArr -> Int -> Symbol
                rbSymV arr n = SymV {sid=0, pos=mkpos sym.offset sym.name.base, vis=v, doc=strMB sym.doc,
                    name = rebuildQN sym.name, typ = nSigma sym.sig, pur = sym.pur,
                    nativ = if sym.nativ == "" then Nothing else Just sym.nativ,
                    expr = rbExpr sym.expr,
                    anno = true, state = StrictChecked, exported = sym.expr != 0,
                    strsig = decodeS sym.stri,
                    depth = sym.depth, rkind = BitSet{set=fromInt sym.rkind},
                    throwing = [ nTau tau | tau <- listFromArray sym.throwing], 
                    over = map rebuildQN (toList sym.over),
                    gargs = map nTau (listFromArray sym.gargs),
                    op = if sym.op == 0 then defaultInfix else from sym.op}
                  where sym = elemAt arr n
                        v = if sym.abst then Abstract else if sym.publik then Public else Protected
                rbSymD :: CT.SymDArr -> Int -> Symbol
                rbSymD arr n = SymD {sid=0, pos=mkpos sym.offset sym.name.base, vis, doc=strMB sym.doc,
                    name = rebuildQN sym.name, cid = sym.cid,
                    typ = nSigma sym.typ,
                    flds = map mkfield fields,
                    op = if sym.op == 0 then defaultInfix else from sym.op,
                    strsig = S [ if f.strict then S[] else U | f::CT.Field <- fields ] }
                  where sym = elemAt arr n
                        fields = toList sym.fields
                        mkfield (fld::CT.Field) = Field{pos=posf, name, doc, vis, strict, typ} where
                            posf = case name of
                                Just n  -> mkpos fld.offset n
                                Nothing -> pos
                            name = strMB fld.name
                            doc  = strMB fld.doc
                            vis  = if fld.privat then Private else Public
                            strict = fld.strict
                            typ = nSigma fld.sigma
                        vis = if sym.priv then Private else if sym.publik then Public else Protected
                        
                rbSymL :: CT.SymLArr -> Int -> Symbol
                rbSymL arr n = SymL {sid=0, pos=mkpos sym.offset sym.name.base, vis, -- doc=strMB sym.doc,
                    name = rebuildQN sym.name, alias = rebuildQN sym.alias}
                  where sym = elemAt arr n
                        vis = if sym.publik then Public else Protected
                rbSymC :: CT.SymC -> Symbol
                rbSymC sym = SymC {sid=0, pos=mkpos sym.offset sym.name.base, vis, doc=strMB sym.doc,
                    name = rebuildQN sym.name,
                    tau  = nTau sym.tau, 
                    supers = sups,
                    insts = zip ins1 ins2,
                    env = empty}
                  where
                    ins1 = mapqs sym.ins1
                    ins2 = mapqs sym.ins2
                    sups = mapqs sym.sups
                    vis = if sym.publik then Public else Protected
                rebuildClass n = do
                    let sym = elemAt fp.symcs n
                    enter (rbSymC sym)
                    foreach (enumFromTo 0 (sym.funs.length-1)) (enter • rbSymV sym.funs)
                    foreach (enumFromTo 0 (sym.lnks.length-1)) (enter • rbSymL sym.lnks)
                rbSymI :: CT.SymI -> Symbol
                rbSymI sym = SymI {sid=0, pos=mkpos sym.offset sym.name.base, 
                    vis=Public, doc=strMB sym.doc,
                    name = rebuildQN sym.name,
                    clas = rebuildQN sym.clas,
                    typ  = nSigma sym.typ,
                    env  = empty}
                rebuildInst n = do
                    let sym = elemAt fp.symis n
                    enter (rbSymI sym)
                    foreach (enumFromTo 0 (sym.funs.length-1)) (enter • rbSymV sym.funs)
                    foreach (enumFromTo 0 (sym.lnks.length-1)) (enter • rbSymL sym.lnks)
                rbSymT :: CT.SymT -> Symbol
                rbSymT sym = SymT {sid=0, pos=mkpos sym.offset sym.name.base,
                    vis = if sym.publik then Public else Protected, doc=strMB sym.doc,
                    name = rebuildQN sym.name,
                    typ  = nSigma sym.typ, product = sym.prod, enum = sym.isEnum,
                    nativ = if sym.nativ == "" then Nothing else Just sym.nativ,
                    pur = sym.pur, newt = sym.newt,
                    kind = nKind sym.kind,
                    gargs = map nTau (listFromArray sym.gargs),
                    env  = empty}
                rebuildTyp n = do
                    let sym = elemAt fp.symts n
                    let rsym = rbSymT sym
                    enter rsym
                    foreach (enumFromTo 0 (sym.cons.length-1)) (enter • rbSymD sym.cons)
                    foreach (enumFromTo 0 (sym.funs.length-1)) (enter • rbSymV sym.funs)
                    foreach (enumFromTo 0 (sym.lnks.length-1)) (enter • rbSymL sym.lnks)
                    case rsym.nativ of
                        Just nativ -> U.nativeType nativ rsym.name
                        nothing    -> return ()


            liftStG do
                foreach [0 .. (fp.symas.length-1)] (enter • rbSymA)
                foreach [0 .. (fp.symcs.length-1)] rebuildClass
                foreach [0 .. (fp.symis.length-1)] rebuildInst
                foreach [0 .. (fp.symts.length-1)] rebuildTyp
                foreach [0 .. (fp.symvs.length-1)] (enter • rbSymV fp.symvs)
                foreach [0 .. (fp.symls.length-1)] (enter • rbSymL fp.symls)
            return (Just fp)



mapqs :: CT.QNameArr -> [QName]
mapqs xs = [ rebuildQN qn | qn <- xs ]

{--
    Insert the basic definitions that we can't write in sourcecode in the symbol table.
    
    > data () = ();
    > data [] a = [] | a `:` [a];
    > data (,) a b = (a,b)     # tuples 2 to 26
    > data (->) a b;
        
 -}
preludeBasics = do
    g <- getST
    
    -- ()
    let unitT  = TName pPreludeBase "()"
        unitC  = MName unitT "()"
        unitCA = VName pPreludeBase "()"
        unitTy = ForAll [] (RhoTau [] (TCon Position.null unitT))
        -- sigmaRhoTau xs t = ForAll xs (RhoTau [] t)
    enter (SymT {name = unitT, typ=unitTy, env = empty, nativ = Nothing,
                product = true, enum = true, pur = false, newt = false,
                kind = KType, gargs = [],
                sid=0, pos=Position.null, vis=Public, doc=Just "Unit type"})
    enter (SymD {name = unitC, typ=unitTy, flds = [], cid = 0,
                sid=0, pos=Position.null, vis=Public, doc=Just "Unit value",
                op = defaultInfix, strsig = U})
    enter (SymL {name = unitCA, alias = unitC,
                sid=0, pos=Position.null, vis=Public})
    -- [], a:as
    let listT    = TName pPreludeBase "[]"
        listNil  = MName listT "[]"
        listCons = MName listT ":"
        va       = TVar Position.null KType "a"
        vb       = TVar Position.null KType "b"
        listRho  = RhoTau [] (TApp (TCon Position.null listT) va)
        listTy   = ForAll [va] listRho
        consTy   = ForAll [va] (RhoFun []
                                    (ForAll [] (RhoTau [] va))
                                    (RhoFun []
                                        (ForAll [] listRho)
                                        listRho))
    -- tuples
    enter (SymT {name = listT, typ = listTy, env = empty, nativ = Nothing,
                product = false, enum = false, pur = false, newt = false,
                kind = Kind.unary, gargs = [],
                sid=0, pos=Position.null, vis=Public, doc=Just "list type"})
    enter (SymD {name = listNil, typ = listTy, flds = [], cid=0,
                sid=0, pos=Position.null, vis=Public, doc=Just "empty list",
                op = defaultInfix, strsig = U})
    enter (SymD {name = listCons, typ = consTy, cid=1,
                   flds = [ aField false (ForAll [] (RhoTau [] va)),
                            aField false (ForAll [] listRho)],
                   sid=0, pos=Position.null, vis=Public, doc=Just "list construction",
                   op = ROP4, strsig = U})
    enter (SymL {name = VName pPreludeBase "[]", alias = listNil,
                   sid=0, pos=Position.null, vis=Public})
    enter (SymL {name = VName pPreludeBase ":", alias = listCons,
                   sid=0, pos=Position.null, vis=Public})
    foreach (enumFromTo 2 26) (tupletype false)

    -- ->
    let funTy = ForAll [va, vb] (RhoTau [] (Tau.tfun va vb))
        funT  = TName pPreludeBase "->"
    enter (SymT {name = funT, typ = funTy, env = empty, nativ = Nothing,
                    product = false, enum = false, 
                    kind = Kind.fun, gargs = [],
                    pur = false, newt = false, sid=0, pos=Position.null, 
                    vis=Public, doc=Just "function"})
  where
    -- unnamed, undocumented field, strictness and type must be given
    aField = Field Position.null Nothing Nothing Public
    vars  = map ctos ['a' .. 'z']
    varks = zipWith (\var kind → TVar{pos=Position.null, var, kind}) vars (repeat KType)
    tvars = map (mvar.{var=}) vars
    commas = repeat ','
    tuple n = "(" ++ packed (take (n-1) commas) ++ ")"
    tupletype strict n = do
        let name = tuple n                          -- "(,)"
            tvs  = take n tvars                     -- TVar 1 "a", TVar 1 "b", ...
            -- vs   = take n vars                      -- "a", "b", ...
            vks  = take n varks                     -- (a::*, b::*, c::*, ....)
            sigmas = map (ForAll [] • RhoTau []) tvs   -- ForAll (RhoTau (TVar 1 "a")), ...
            flds   = map (aField strict) sigmas       -- (Nothing, a), (Nothing, b)
            tupleT   = TName pPreludeBase name          -- Prelude.(,)
            tupleC   = MName tupleT   name          -- Prelude.(,).(,)
            tupleRho = RhoTau [] (Tau.mkapp (TCon Position.null tupleT) tvs)   -- (a,b,...)
            tupleSig = ForAll vks tupleRho              -- forall a b....(a,b, ...)
            conRho   = foldr (RhoFun []) tupleRho sigmas      -- a -> b -> ... -> (a,b, ...)
        enter (SymT {name = tupleT, typ = tupleSig, env = empty, nativ = Nothing,
                        product = true, enum = false, kind = Kind.kind n,
                        sid=0, pos=Position.null, vis=Public, doc=Just (show n ++ "-tuple"),
                        pur = false, newt = false, gargs = []})
        enter (SymD {name = tupleC, typ = ForAll vks conRho, flds = flds, cid=0,
                        sid=0, pos=Position.null, vis=Public, doc=Just (show n ++ "-tuple constructor"),
                        op = defaultInfix, strsig = U})
        enter (SymL {name = VName pPreludeBase name, alias = tupleC,
                        sid=0, pos=Position.null, vis=Public})

mvar :: Tau
mvar = TVar Position.null KType ""
